;; -*-Scheme-*-
(module
 pthread
 (import os misc)
 (extern
  (include "pthread.h")
  (export pthread-create-callback "bigloo_pthread_create_callback")
  )
 (export
  (pthread-create-callback proc::procedure)
  (pthread-create::pthread proc::procedure #!key detached schedpolicy schedparam inheritsched scope)
  (pthread-mutex-init::pthread-mutex . attrs)
  (pthread-mutex-trylock::bool mutex::pthread-mutex)
  )
 )

(define-errcode pthread_code pthread-check-error)
(define-static (pthread-check-error name::bstring code::int)
  (unless(=fx 0 code)
	 (errno code)
	 (cerror name))
  code)

(define-enum-extended (pthread pthread_t))

;Initializers. 

;#define PTHREAD_MUTEX_INITIALIZER \
;  {0, 0, 0, PTHREAD_MUTEX_TIMED_NP, __LOCK_INITIALIZER}
;#ifdef __USE_GNU
;# define PTHREAD_RECURSIVE_MUTEX_INITIALIZER_NP \
;  {0, 0, 0, PTHREAD_MUTEX_RECURSIVE_NP, __LOCK_INITIALIZER}
;# define PTHREAD_ERRORCHECK_MUTEX_INITIALIZER_NP \
;  {0, 0, 0, PTHREAD_MUTEX_ERRORCHECK_NP, __LOCK_INITIALIZER}
;# define PTHREAD_ADAPTIVE_MUTEX_INITIALIZER_NP \
;  {0, 0, 0, PTHREAD_MUTEX_ADAPTIVE_NP, __LOCK_INITIALIZER}
;#endif

;#define PTHREAD_COND_INITIALIZER {__LOCK_INITIALIZER, 0}

;#ifdef __USE_UNIX98
;# define PTHREAD_RWLOCK_INITIALIZER \
;  { __LOCK_INITIALIZER, 0, NULL, NULL, NULL,				      \
;    PTHREAD_RWLOCK_DEFAULT_NP, PTHREAD_PROCESS_PRIVATE }
;#endif
;#ifdef __USE_GNU
;# define PTHREAD_RWLOCK_WRITER_NONRECURSIVE_INITIALIZER_NP \
;  { __LOCK_INITIALIZER, 0, NULL, NULL, NULL,				      \
;    PTHREAD_RWLOCK_PREFER_WRITER_NONRECURSIVE_NP, PTHREAD_PROCESS_PRIVATE }
;#endif

;Values for attributes. 

;enum
;{
;  PTHREAD_CREATE_JOINABLE,
;  PTHREAD_CREATE_DETACHED
;};

;enum
;{
;  PTHREAD_INHERIT_SCHED,
;  PTHREAD_EXPLICIT_SCHED
;};

;enum
;{
;  PTHREAD_SCOPE_SYSTEM,
;  PTHREAD_SCOPE_PROCESS
;};

;enum
;{
;  PTHREAD_MUTEX_TIMED_NP,
;  PTHREAD_MUTEX_RECURSIVE_NP,
;  PTHREAD_MUTEX_ERRORCHECK_NP,
;  PTHREAD_MUTEX_ADAPTIVE_NP
;};

;enum
;{
;  PTHREAD_PROCESS_PRIVATE,
;  PTHREAD_PROCESS_SHARED
;};

;#ifdef __USE_UNIX98
;enum
;{
;  PTHREAD_RWLOCK_PREFER_READER_NP,
;  PTHREAD_RWLOCK_PREFER_WRITER_NP,
;  PTHREAD_RWLOCK_PREFER_WRITER_NONRECURSIVE_NP,
;  PTHREAD_RWLOCK_DEFAULT_NP = PTHREAD_RWLOCK_PREFER_WRITER_NP
;};
;#endif	Unix98

;#define PTHREAD_ONCE_INIT 0

;Special constants

;#ifdef __USE_XOPEN2K
;-1 is distinct from 0 and all errno constants
;# define PTHREAD_BARRIER_SERIAL_THREAD -1
;#endif

;Cleanup buffers

;struct _pthread_cleanup_buffer
;{
;  void (*__routine) (void *);		  Function to call. 
;  void *__arg;				  Its argument. 
;  int __canceltype;			  Saved cancellation type.
;  struct _pthread_cleanup_buffer *__prev; Chaining of cleanup functions. 
;};

;Cancellation

;enum
;{
;  PTHREAD_CANCEL_ENABLE,
;  PTHREAD_CANCEL_DISABLE
;};
;enum
;{
;  PTHREAD_CANCEL_DEFERRED,
;  PTHREAD_CANCEL_ASYNCHRONOUS
;};
;#define PTHREAD_CANCELED ((void *) -1)


;Function for handling threads. 

;Create a thread with given attributes ATTR (or default attributes
;   if ATTR is NULL), and call function START_ROUTINE with given
;   arguments ARG. 
(define (pthread-create-callback proc::procedure)
  (proc))

(define (pthread-create::pthread proc::procedure #!key detached schedpolicy sched-priority inheritsched scope)
  (object-ref proc)
  (let((thread::pthread (pragma::pthread "0"))
       (attrs::void* (pragma::void* "GC_malloc_atomic(sizeof(pthread_attr_t))")))
    (pragma "pthread_attr_init ((pthread_attr_t *)$1)"attrs)
    (when detached
	  (pragma "pthread_attr_setdetachstate($1, PTHREAD_CREATE_DETACHED)" attrs))
    (when sched-priority
	  (let((sched-priority::int sched-priority)
	       (sched-param-s::void*
		(pragma::void* "GC_malloc_atomic(sizeof(struct sched_param))")))
	    (pragma::int "sched_getparam(0, $1)"sched-param-s)
	    (pragma "((struct sched_param*)$1)->sched_priority = $2"
		    sched-param-s sched-priority)
	    (pthread-check-error
	     "pthread_attr_setschedparam"
	     (pragma::int "pthread_attr_setschedparam($1, $2)"
			  attrs sched-param-s))))
    (when schedpolicy
	  (pthread-check-error
	   "pthread_attr_setschedpolicy"
	   (case schedpolicy
	     ((other)
	      (pragma::int "pthread_attr_setschedpolicy($1, SCHED_OTHER)"
			   attrs))
	     ((fifo)
	      (pragma::int "pthread_attr_setschedpolicy($1, SCHED_FIFO)"
			   attrs))
	     ((rr)
	      (pragma::int "pthread_attr_setschedpolicy($1, SCHED_RR)"
			   attrs))
	     (else
	      (error "pthread-create" "invalid schedpolicy value"
		     schedpolicy)))))
    (when inheritsched
	  (pthread-check-error
	   "pthread_attr_setinheritsched"
	   (pragma::int
	    "pthread_attr_setinheritsched($1, PTHREAD_INHERIT_SCHED)"
	    attrs)))
    (when scope
	  (pthread-check-error
	   "pthread_attr_setscope"
	   (case scope
	     ((system)
	      (pragma::int "pthread_attr_setscope($1, PTHREAD_SCOPE_SYSTEM)"
			   attrs))
	     ((process)
	      (pragma::int "pthread_attr_setscope($1, PTHREAD_SCOPE_PROCESS)"
			   attrs))
	     (else
	      (error "pthread-create" "invalid scope value"scope)))))

    (pragma "{
typedef void *(*pthread_start_routine) (void *);
int GC_pthread_create(pthread_t *new_thread,
  const pthread_attr_t *attr,
  void *(*start_routine)(void *), void *arg);
GC_pthread_create (&$1, (const pthread_attr_t *)$3, (pthread_start_routine)bigloo_pthread_create_callback, $2);}"
	    thread proc attrs)
    (pragma "pthread_attr_destroy ($1)"attrs)
    thread))

;Obtain the identifier of the current thread. 
(define-func pthread_self pthread ())

;Compare two thread identifiers. 
(define-func pthread_equal int ((pthread thread1)(pthread thread2)))

;Terminate calling thread. 
(define-func pthread_exit void ((void* retval (= "NULL"))))

;Make calling thread wait for termination of the thread TH.  The
;   exit status of the thread is stored in *THREAD_RETURN, if THREAD_RETURN
;   is not NULL. 
(define (pthread-join thread::pthread)
  (let((result::void* "NULL"))
    (pthread-check-error
     "pthread-join"
     (pragma::int "pthread_join($1, &$2)"thread result))
    (pragma::obj "$1"result)))

;Indicate that the thread TH is never to be joined with PTHREAD_JOIN.
;   The resources of TH will therefore be freed immediately when it
;   terminates, instead of waiting for another thread to perform PTHREAD_JOIN
;   on it. 
(define-func pthread_detach pthread_code ((pthread th)))

;Functions for scheduling control. 

;Set the scheduling parameters for TARGET_THREAD according to POLICY
;   and *PARAM. 
;extern int pthread_setschedparam (pthread_t __target_thread, int __policy,
;				  __const struct sched_param *__param)
;     __THROW;

;Return in *POLICY and *PARAM the scheduling parameters for TARGET_THREAD. 
;extern int pthread_getschedparam (pthread_t __target_thread,
;				  int *__restrict __policy,
;				  struct sched_param *__restrict __param)
;     __THROW;

;#ifdef __USE_GNU
;Yield the processor to another thread or process.
;   This function is similar to the POSIX `sched_yield' function but
;   might be differently implemented in the case of a m-on-n thread
;   implementation. 
;extern int pthread_yield (void) __THROW;
;#endif

;Functions for mutex handling. 

(define-object (pthread-mutex pthread_mutex_t*) ())

;Initialize MUTEX using attributes in *MUTEX_ATTR, or use the
;   default values if later is NULL. 

(define (pthread-mutex-init::pthread-mutex . attrs)
  ;; TODO: process attributes
  (let((mutex::pthread-mutex
	(pragma::pthread-mutex
	 "(pthread_mutex_t*)GC_malloc_atomic(sizeof(pthread_mutex_t))")))
    (pthread-check-error
     "pthread_mutex_init"
     (pragma::int "pthread_mutex_init($1, NULL)" mutex))
    mutex))

;Destroy MUTEX. 
(define-func pthread_mutex_destroy pthread_code ((pthread-mutex mutex)))

;Try to lock MUTEX. 
(define (pthread-mutex-trylock mutex::pthread-mutex)
  (let((result(pragma::int "pthread_mutex_trylock ($1)"mutex)))
    (cond((pragma::bool "$1 == 0" result)
	  #t)
	 ((pragma::bool "$1 == EBUSY" result)
	  #f)
	 (else
	  (pthread-check-error "pthread-mutex-trylock"result)))))

;Wait until lock for MUTEX becomes available and lock it. 
(define-func pthread_mutex_lock pthread_code
  ((pthread-mutex mutex)))

;Unlock MUTEX. 

(define-func pthread_mutex_unlock pthread_code((pthread-mutex mutex)))
       
;Functions for handling mutex attributes. 

;(define-object pthread_mutexattr ())

;;Initialize mutex attribute object ATTR with default attributes
;;   (kind is PTHREAD_MUTEX_TIMED_NP). 
;(define-func pthread_mutexattr_init pthread_code
;  ((pthread_mutexattr attr)))

;;Destroy mutex attribute object ATTR. 
;(define-func pthread_mutexattr_destroy pthread_code
;  ((pthread_mutexattr attr)))

;Get the process-shared flag of the mutex attribute ATTR. 
;extern int pthread_mutexattr_getpshared (__const pthread_mutexattr_t *
;					 __restrict __attr,
;					 int *__restrict __pshared) __THROW;

;Set the process-shared flag of the mutex attribute ATTR. 
;extern int pthread_mutexattr_setpshared (pthread_mutexattr_t *__attr,
;					 int __pshared) __THROW;

;Functions for handling conditional variables. 

;Initialize condition variable COND using attributes ATTR, or use
;   the default values if later is NULL. 
;extern int pthread_cond_init (pthread_cond_t *__restrict __cond,
;			      __const pthread_condattr_t *__restrict
;			      __cond_attr) __THROW;

;Destroy condition variable COND. 
;extern int pthread_cond_destroy (pthread_cond_t *__cond) __THROW;

;Wake up one thread waiting for condition variable COND. 
;extern int pthread_cond_signal (pthread_cond_t *__cond) __THROW;

;Wake up all threads waiting for condition variables COND. 
;extern int pthread_cond_broadcast (pthread_cond_t *__cond) __THROW;

;Wait for condition variable COND to be signaled or broadcast.
;   MUTEX is assumed to be locked before. 
;extern int pthread_cond_wait (pthread_cond_t *__restrict __cond,
;			      pthread_mutex_t *__restrict __mutex) __THROW;

;Wait for condition variable COND to be signaled or broadcast until
;   ABSTIME.  MUTEX is assumed to be locked before.  ABSTIME is an
;   absolute time specification; zero is the beginning of the epoch
;   (00:00:00 GMT, January 1, 1970). 
;extern int pthread_cond_timedwait (pthread_cond_t *__restrict __cond,
;				   pthread_mutex_t *__restrict __mutex,
;				   __const struct timespec *__restrict
;				   __abstime) __THROW;

;Functions for handling condition variable attributes. 

;Initialize condition variable attribute ATTR. 
;extern int pthread_condattr_init (pthread_condattr_t *__attr) __THROW;

;Destroy condition variable attribute ATTR. 
;extern int pthread_condattr_destroy (pthread_condattr_t *__attr) __THROW;

;Get the process-shared flag of the condition variable attribute ATTR. 
;extern int pthread_condattr_getpshared (__const pthread_condattr_t *
;					__restrict __attr,
;					int *__restrict __pshared) __THROW;

;Set the process-shared flag of the condition variable attribute ATTR. 
;extern int pthread_condattr_setpshared (pthread_condattr_t *__attr,
;					int __pshared) __THROW;


;#ifdef __USE_UNIX98
;Functions for handling read-write locks. 

;Initialize read-write lock RWLOCK using attributes ATTR, or use
;   the default values if later is NULL. 
;extern int pthread_rwlock_init (pthread_rwlock_t *__restrict __rwlock,
;				__const pthread_rwlockattr_t *__restrict
;				__attr) __THROW;

;Destroy read-write lock RWLOCK. 
;extern int pthread_rwlock_destroy (pthread_rwlock_t *__rwlock) __THROW;

;Acquire read lock for RWLOCK. 
;extern int pthread_rwlock_rdlock (pthread_rwlock_t *__rwlock) __THROW;

;Try to acquire read lock for RWLOCK. 
;extern int pthread_rwlock_tryrdlock (pthread_rwlock_t *__rwlock) __THROW;

;#ifdef __USE_XOPEN2K
;Try to acquire read lock for RWLOCK or return after specfied time. 
;extern int pthread_rwlock_timedrdlock (pthread_rwlock_t *__restrict __rwlock,
;				       __const struct timespec *__restrict
;				       __abstime) __THROW;
;#endif

;Acquire write lock for RWLOCK. 
;extern int pthread_rwlock_wrlock (pthread_rwlock_t *__rwlock) __THROW;

;Try to acquire write lock for RWLOCK. 
;extern int pthread_rwlock_trywrlock (pthread_rwlock_t *__rwlock) __THROW;

;#ifdef __USE_XOPEN2K
;Try to acquire write lock for RWLOCK or return after specfied time. 
;extern int pthread_rwlock_timedwrlock (pthread_rwlock_t *__restrict __rwlock,
;				       __const struct timespec *__restrict
;				       __abstime) __THROW;
;#endif

;Unlock RWLOCK. 
;extern int pthread_rwlock_unlock (pthread_rwlock_t *__rwlock) __THROW;


;Functions for handling read-write lock attributes. 

;Initialize attribute object ATTR with default values. 
;extern int pthread_rwlockattr_init (pthread_rwlockattr_t *__attr) __THROW;

;Destroy attribute object ATTR. 
;extern int pthread_rwlockattr_destroy (pthread_rwlockattr_t *__attr) __THROW;

;Return current setting of process-shared attribute of ATTR in PSHARED. 
;extern int pthread_rwlockattr_getpshared (__const pthread_rwlockattr_t *
;					  __restrict __attr,
;					  int *__restrict __pshared) __THROW;

;Set process-shared attribute of ATTR to PSHARED. 
;extern int pthread_rwlockattr_setpshared (pthread_rwlockattr_t *__attr,
;					  int __pshared) __THROW;

;Return current setting of reader/writer preference. 
;extern int pthread_rwlockattr_getkind_np (__const pthread_rwlockattr_t *__attr,
;					  int *__pref) __THROW;

;Set reader/write preference. 
;extern int pthread_rwlockattr_setkind_np (pthread_rwlockattr_t *__attr,
;					  int __pref) __THROW;
;#endif

;#ifdef __USE_XOPEN2K
;The IEEE Std. 1003.1j-2000 introduces functions to implement
;   spinlocks. 

;Initialize the spinlock LOCK.  If PSHARED is nonzero the spinlock can
;   be shared between different processes. 
;extern int pthread_spin_init (pthread_spinlock_t *__lock, int __pshared)
;     __THROW;

;Destroy the spinlock LOCK. 
;extern int pthread_spin_destroy (pthread_spinlock_t *__lock) __THROW;

;Wait until spinlock LOCK is retrieved. 
;extern int pthread_spin_lock (pthread_spinlock_t *__lock) __THROW;

;Try to lock spinlock LOCK. 
;extern int pthread_spin_trylock (pthread_spinlock_t *__lock) __THROW;

;Release spinlock LOCK. 
;extern int pthread_spin_unlock (pthread_spinlock_t *__lock) __THROW;


;Barriers are a also a new feature in 1003.1j-2000.

;extern int pthread_barrier_init (pthread_barrier_t *__restrict __barrier,
;				 __const pthread_barrierattr_t *__restrict
;				 __attr, unsigned int __count) __THROW;

;extern int pthread_barrier_destroy (pthread_barrier_t *__barrier) __THROW;

;extern int pthread_barrierattr_init (pthread_barrierattr_t *__attr) __THROW;

;extern int pthread_barrierattr_destroy (pthread_barrierattr_t *__attr) __THROW;

;extern int pthread_barrierattr_getpshared (__const pthread_barrierattr_t *
;					   __restrict __attr,
;					   int *__restrict __pshared) __THROW;

;extern int pthread_barrierattr_setpshared (pthread_barrierattr_t *__attr,
;					   int __pshared) __THROW;

;extern int pthread_barrier_wait (pthread_barrier_t *__barrier) __THROW;
;#endif


;Functions for handling thread-specific data. 

;Create a key value identifying a location in the thread-specific
;   data area.  Each thread maintains a distinct thread-specific data
;   area.  DESTR_FUNCTION, if non-NULL, is called with the value
;   associated to that key when the key is destroyed.
;   DESTR_FUNCTION is not called if the value associated is NULL when
;   the key is destroyed. 
;extern int pthread_key_create (pthread_key_t *__key,
;			       void (*__destr_function) (void *)) __THROW;

;Destroy KEY. 
;extern int pthread_key_delete (pthread_key_t __key) __THROW;

;Store POINTER in the thread-specific data slot identified by KEY.
;extern int pthread_setspecific (pthread_key_t __key,
;				__const void *__pointer) __THROW;

;Return current value of the thread-specific data slot identified by KEY. 
;extern void *pthread_getspecific (pthread_key_t __key) __THROW;


;Functions for handling initialization. 

;Guarantee that the initialization function INIT_ROUTINE will be called
;   only once, even if pthread_once is executed several times with the
;   same ONCE_CONTROL argument. ONCE_CONTROL must point to a static or
;   extern variable initialized to PTHREAD_ONCE_INIT. 
;extern int pthread_once (pthread_once_t *__once_control,
;			 void (*__init_routine) (void)) __THROW;


;Functions for handling cancellation. 

;Set cancelability state of current thread to STATE, returning old
;   state in *OLDSTATE if OLDSTATE is not NULL. 
;extern int pthread_setcancelstate (int __state, int *__oldstate) __THROW;

;Set cancellation state of current thread to TYPE, returning the old
;   type in *OLDTYPE if OLDTYPE is not NULL. 
;extern int pthread_setcanceltype (int __type, int *__oldtype) __THROW;

;Cancel THREAD immediately or at the next possibility. 
;extern int pthread_cancel (pthread_t __thread) __THROW;

;Test for pending cancellation for the current thread and terminate
;   the thread as per pthread_exit(PTHREAD_CANCELED) if it has been
;   cancelled. 
;extern void pthread_testcancel (void) __THROW;


;Install a cleanup handler: ROUTINE will be called with arguments ARG
;   when the thread is cancelled or calls pthread_exit.  ROUTINE will also
;   be called with arguments ARG when the matching pthread_cleanup_pop
;   is executed with non-zero EXECUTE argument.
;   pthread_cleanup_push and pthread_cleanup_pop are macros and must always
;   be used in matching pairs at the same nesting level of braces.

;#define pthread_cleanup_push(routine,arg) \
;  { struct _pthread_cleanup_buffer _buffer;				      \
;    _pthread_cleanup_push (&_buffer, (routine), (arg));

;extern void _pthread_cleanup_push (struct _pthread_cleanup_buffer *__buffer,
;				   void (*__routine) (void *),
;				   void *__arg) __THROW;

;Remove a cleanup handler installed by the matching pthread_cleanup_push.
;   If EXECUTE is non-zero, the handler function is called.

;#define pthread_cleanup_pop(execute) \
;    _pthread_cleanup_pop (&_buffer, (execute)); }

;extern void _pthread_cleanup_pop (struct _pthread_cleanup_buffer *__buffer,
;				  int __execute) __THROW;

;Install a cleanup handler as pthread_cleanup_push does, but also
;   saves the current cancellation type and set it to deferred cancellation. 

;#ifdef __USE_GNU
;# define pthread_cleanup_push_defer_np(routine,arg) \
;  { struct _pthread_cleanup_buffer _buffer;				      \
;    _pthread_cleanup_push_defer (&_buffer, (routine), (arg));

;extern void _pthread_cleanup_push_defer (struct _pthread_cleanup_buffer *__buffer,
;					 void (*__routine) (void *),
;					 void *__arg) __THROW;

;Remove a cleanup handler as pthread_cleanup_pop does, but also
;   restores the cancellation type that was in effect when the matching
;   pthread_cleanup_push_defer was called. 

;# define pthread_cleanup_pop_restore_np(execute) \
;  _pthread_cleanup_pop_restore (&_buffer, (execute)); }

;extern void _pthread_cleanup_pop_restore (struct _pthread_cleanup_buffer *__buffer,
;					  int __execute) __THROW;
;#endif


;#ifdef __USE_XOPEN2K
;Get ID of CPU-time clock for thread THREAD_ID. 
;extern int pthread_getcpuclockid (pthread_t __thread_id,
;				  clockid_t *__clock_id) __THROW;
;#endif


;Functions for handling signals. 
;#include <bits/sigthread.h>


;Functions for handling process creation and process execution. 

;Install handlers to be called when a new process is created with FORK.
;   The PREPARE handler is called in the parent process just before performing
;   FORK. The PARENT handler is called in the parent process just after FORK.
;   The CHILD handler is called in the child process.  Each of the three
;   handlers can be NULL, meaning that no handler needs to be called at that
;   point.
;   PTHREAD_ATFORK can be called several times, in which case the PREPARE
;   handlers are called in LIFO order (last added with PTHREAD_ATFORK,
;   first called before FORK), and the PARENT and CHILD handlers are called
;   in FIFO (first added, first called). 

;extern int pthread_atfork (void (*__prepare) (void),
;			   void (*__parent) (void),
;			   void (*__child) (void)) __THROW;

;Terminate all threads in the program except the calling process.
;   Should be called just before invoking one of the exec*() functions. 

;extern void pthread_kill_other_threads_np (void) __THROW;

